Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue64/Alfresco/AAHpClss.pas

Pascal/Delphi Source File | 2000-10-23 | 6.3 KB | 222 lines

{*********************************************************}
{* AAHpClss                                              *}
{* Copyright (c) Julian M Bucknall 2000                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco: Object creation analyzer         *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AAHpClss;

{Notes: This unit should be put first in the project's uses list, or,
        if SHAREMEM is being used, second (ie, just under ShareMem).
        In other words you should have this uses list in your
        project's DPR file:

          uses
            HeapClss,
            ..other units..

        or, this one:

          uses
            ShareMem,
            HeapClss,
            ..other units..

        The code in the unit tracks every object creation and free
        providing that NewInstance and FreeInstance have not been
        overridden and the ancestor's version called. It produces a
        log file called C:\AAClass.LOG.

        The log file consists of a line per allocation or free in the
        follwing format:

          <TYPE> <ADDRESS> <CLASS NAME>

        where <TYPE> is 'New:' or 'Free:', <ADDRESS> is the address of
        the just created object or the object about to be freed, and
        <CLASS NAME> is the name of the class for the object in
        question. Here's an example, extracted from an actual log:

          Free: 00bc598c TList
          New:  00bc6e10 TList
          Free: 00bc6e10 TList
          New:  00bc6e10 TObject
          Free: 00bc6e10 TObject
          Free: 00bc560c TFont

        If you want to alter this code to add more functionality,
        notice that you cannot cause any memory allocations to occur
        in the GetMem replacement routine, otherwise you will blow the
        stack pretty quickly.}

interface

implementation

var
  Log : System.Text;

  OrigHeap : TMemoryManager;
  OurHeap  : TMemoryManager;

  NewInstAddr  : longint;
  FreeInstAddr : longint;
  CreateAddr   : longint;

type
  PNewInstCallStack = ^TNewInstCallStack;
  TNewInstCallStack = record
    csOldEBP        : longint;
    csGetMemRetAddr : longint; // actually a pointer
    csNewInstRetAddr: longint; // actually a pointer
    csClassInstance : TClass;
  end;

  PFreeInstCallStack = ^TFreeInstCallStack;
  TFreeInstCallStack = record
    csOldEBP         : longint;
    csFreeMemRetAddr : longint; //pointer;
    csFreeInstRetAddr: longint; //pointer;
  end;

{===Helper routines==================================================}
function ByteAsHex(Dest : PChar; B : byte) : PChar;
const
  HexChars : array [0..15] of char = '0123456789abcdef';
begin
  if (Dest <> nil) then begin
    Dest[0] := HexChars[B shr 4];
    Dest[1] := HexChars[B and $F];
    Dest[2] := #0;
  end;
  Result := Dest;
end;
{--------}
function PointerAsHex(Dest : PChar; P : pointer) : PChar;
var
  L : longint;
begin
  if (Dest <> nil) then begin
    L := longint(P);
    ByteAsHex(Dest, L shr 24);
    inc(Dest, 2);
    ByteAsHex(Dest, (L shr 16) and $FF);
    inc(Dest, 2);
    ByteAsHex(Dest, (L shr 8) and $FF);
    inc(Dest, 2);
    ByteAsHex(Dest, L and $FF);
  end;
  Result := Dest;
end;
{====================================================================}


{===Replacement memory routines======================================}
function OurGetMem(Size: Integer): Pointer;
var
  CallStack : PNewInstCallStack;
  PtrString : array [0..8] of char;
begin
  {get the call stack}
  asm
    mov CallStack, ebp
  end;

  {allocate the memory}
  Result := OrigHeap.GetMem(Size);

  {if this was called from TObject.NewInstance, output a line to the
   log showing the object details}
  if (NewInstAddr <= CallStack^.csNewInstRetAddr) and
     (CallStack^.csNewInstRetAddr < FreeInstAddr) then begin
    PointerAsHex(PtrString, Result);
    writeln(Log, 'New:  ', PtrString, ' ',
            Size:10, ' ',
            CallStack^.csClassInstance.ClassName);
  end;
end;
{--------}
function OurFreeMem(P : Pointer) : integer;
type
  PClass = ^TClass;
var
  CallStack : PFreeInstCallStack;
  ClassPtr  : PClass;
  PtrString : array [0..8] of char;
begin
  {get the call stack}
  asm
    mov CallStack, ebp
  end;

  {if this was called from TObject.FreeInstance, output a line to the
   log showing the object details. Note this only works because the
   first field of the object being freed is the class pointer}
  if (FreeInstAddr <= CallStack^.csFreeInstRetAddr) and
     (CallStack^.csFreeInstRetAddr < CreateAddr) then begin
    PointerAsHex(PtrString, P);
    ClassPtr := P;
    writeln(Log, 'Free: ', PtrString, ' ',
            ' ':10, ' ',
            ClassPtr^.ClassName);
  end;

  {free the memory}
  Result := OrigHeap.FreeMem(P);
end;
{====================================================================}


{===Initialization/finalization======================================}
procedure InitializeUnit;
begin
  {get the addresses of NewInstance, FreeInstance and Create as
   integers}
  NewInstAddr := longint(@TObject.NewInstance);
  FreeInstAddr := longint(@TObject.FreeInstance);
  CreateAddr := longint(@TObject.Create);

  {open up the log file}
  System.Assign(Log, 'C:\AAClass.LOG');
  System.Rewrite(Log);
  writeln(Log, 'Algorithms Alfresco Object Creation/Destruction Log');
  writeln(Log);
  writeln(Log, 'Type   Address       Size Class');

  {get the original manager}
  GetMemoryManager(OrigHeap);

  {set up our heap manager}
  OurHeap.GetMem := OurGetMem;
  OurHeap.FreeMem := OurFreeMem;
  OurHeap.ReallocMem := OrigHeap.ReallocMem;

  {replace heap manager with ours}
  SetMemoryManager(OurHeap);
end;
{--------}
procedure FinalizeUnit;
begin
  {restore the original manager}
  SetMemoryManager(OrigHeap);

  {close the log}
  writeln(Log, '..finished..');
  System.Close(Log);
end;
{====================================================================}

initialization
  InitializeUnit;

finalization
  FinalizeUnit;

end.